unit wgetiff;

{****************************************************************************}
interface

uses Wincrt,Windos,
      CartoCmds,        (* Contient les def. globales *)
      tit_win,get_win,gmuf_win,aux_win,coul_win;


(*************************** gethff - 3 Nov 90 *****************************)

function get_tiff(nomsc:st64;var nbands, nlig_capt, ncol_capt:word;
                  var FormatType:Num_Lay): integer;

{****************************************************************************}

implementation

(*************************** gethff - 5 Juin 91 *****************************)

function get_tiff(nomsc:st64;var nbands, nlig_capt, ncol_capt:word;
                  var FormatType:Num_Lay): integer;

const

(* FORMAT D'IMAGE TIFF *)

     card_capt = 8;
var
      data_offset, palette_offset, max_offset:longint;
      table_tiff:Pctable;
      Mode:Integer;

var   ier,i,l,k,n,nuko,valeur:integer;
      nuk_upda:integer;
      rvb,r,v,b,nut,erreur:integer;
      rc,keybid:char;
      nomkan,nomh:st64;
      pathpos:integer;
      tbtx:st10;

      i_code:integer;

      ligne,error,nnn,ioerror:integer;       (* READHALO *)

      tiff:file;
      buf_tiff:byte;

      buf_word:array[1..2] of byte;
      buf_word1:array[1..2] of byte;
      buf_word2:array[1..2] of byte;
      buf_off:array[1..4] of byte;
      buf_long:array[1..4] of byte;
      bufint_long:array[1..2] of integer;

      val_word1:word      absolute buf_word1;
      val_word2:word      absolute buf_word2;
      val_word:word       absolute buf_word;
      val_long:longint    absolute buf_long;
      val_off:longint     absolute buf_off;
      valint_long:longint absolute bufint_long;

      byteor:array[1..2] of char;
      version:word;
      ifd_off:longint;
      num_tags:word;
      tag_id:word;
      tag_type:word;
      tag_long:word;

      sub_type:word;

      tab_cod:array[1..768] of byte;

      nbs_samples:word;
      max_r,max_g,max_b:integer;
      nbcol_st:integer;

      lay_store:integer;

      x_col,y_lig,posit,n_col:integer;
      strnlig,strncol:string;

label 999;

(* NIH code *)

Const
    {TIFF Constants}
		short = 3;
		long = 4;
		NewSubfileType = 254;
		ImageWidth = 256;
		ImageLength = 257;
		BitsPerSample = 258;
		Compression = 259;
		PhotoInterp = 262;
		StripOffsets = 273;
		SamplesPerPixelTag = 277;
		RowsPerStrip = 278;
		StripByteCount = 279;
		XResolution = 282;
		YResolution = 283;
		PlanarConfigTag = 284;
		ResolutionUnit = 296;
		ColorMapTag = 320;
		ImageHdrTag = -22222; {43314}
		TiffFillerSize = 67;
		RoiHandleSize = 5;
		CancelResetID = 3;
		npcItems = 7;

type
  TiffHdr = record
    ByteOrder: array[1..2] of char;
    Version: integer;
    FirstIFDOffset: LongInt;
  end;
  TiffEntry = record
    TagField: integer;
    ftype: integer;
    length: LongInt;
    offset: LongInt;
  end;
  TiffInfoRec = record
    Width, Height: integer;
    BitsPerPixel: integer;
    SamplesPerPixel: integer;
    PlanarConfig: integer;
    ZeroIsBlack: boolean;
    OffsetToData, OffsetToColorMap, OffsetToImageHeader: LongInt;
    Resolution: real; (* Normalement 5 bytes dit Extended *)
    ResUnits: (tCentimeters, tInches, tNoUnits);
    NextIFD: LongInt;
  end;

const
  importing = FALSE;

var
  IntelByteOrder: boolean;
  HasColorMap: boolean;

  DirOffset: LongInt;
  TiffInfo: TiffInfoRec;

	procedure Swap2Bytes (var i: integer);
		type
			atype = array[1..2] of char;
		var
			a: atype;
			c: char;
	begin
		a := atype(i);
		c := a[1];
		a[1] := a[2];
		a[2] := c;
		i := integer(a)
	end;


	procedure Swap4Bytes (var i: LongInt);
		type
			ostype = array[1..4] of char;
		var
			a: ostype;
			c: char;
	begin
		a := ostype(i);
		c := a[1];
		a[1] := a[4];
		a[4] := c;
		c := a[2];
		a[2] := a[3];
		a[3] := c;
		i := LongInt(a)
	end;

function OpenTiffHeader (var tiff: file; var DirOffset: LongInt): boolean;
 var
   TiffHeader: TiffHdr;
   ByteCount: LongInt;
   err : integer;
 begin
   ByteCount := 8;
   Seek(tiff, 0);
   blockread(tiff, TiffHeader, ByteCount, ier);
   if ioresult <> 0 then begin
     OpenTiffHeader := false;
     exit;
   end;
   with TiffHeader do begin
     IntelByteOrder := ByteOrder = 'II';
     if (ByteOrder <> 'MM') and (ByteOrder <> 'II') then begin
       writeln('Invalid TIFF header.');
       OpenTiffHeader := false;
       exit;
     end;
     DirOffset := FirstIFDOffset;
     if not(IntelByteOrder) then Swap4Bytes(DirOffset);
     OpenTiffHeader := true;
   end;
 end;

(*
TIFF Scan of E:\IMAGE01\PXS92.TIF:

Motorola type
current IFD at:  8
number of tags in current IFD:  14
NewSubFileType         tag: 254 type: 4 count: 1  data: 0
width                  tag: 256 type: 4 count: 1  data: 1500
height                 tag: 257 type: 4 count: 1  data: 1500
BitsPerSample          tag: 258 type: 3 count: 3  data: 
8	8	8	
Compression            tag: 259 type: 3 count: 1  data: 1
PhotoInterp            tag: 262 type: 3 count: 1  data: 2
stripOffsets           tag: 273 type: 4 count: 750  data: 
*)

procedure GetTiffEntry (var tiff: file; var tag: integer; var N, value: LongInt);
  var
    IFDEntry: TiffEntry;
    ByteCount: LongInt;
    IntValue: integer;
    str: string;
(*
TiffEntry;
    TagField: integer;
    ftype: integer;
    length: LongInt;
    offset: LongInt;
*)
  begin
    ByteCount := 12;
    blockread(tiff, IFDentry, ByteCount, ier);
    with IFDEntry do begin
      tag := TagField;
      N := length;
      if not(IntelByteOrder) then begin
        Swap2Bytes(tag);
        Swap2Bytes(ftype);
        Swap4Bytes(N);
      end;
      value := offset; (* LongInt *)
      if (ftype = short) and (N = 1) then begin
	if not(IntelByteOrder) then Swap4Bytes(value);
        value := value SHR 16;
      end else if not(IntelByteOrder) then Swap4Bytes(value);
(*      writeln('tag : ',tag:4,' type : ',ftype:3,' count : ',N:3,' data : ',value); *)
      write('tag : ',tag:4,' - ');
    end;
  end;

function OpenTiffDirectory (var tiff: file; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean;
 const
   NoUnit = 1;
   inch = 2;
   centimeter = 3;
 var
   ByteCount, length, ftype, N, value, BytesPerStrip, SaveFPos: LongInt;
   nEntries, i, tag, entry: integer;
   StripOffsetsArray: array[1..2] of LongInt;
   xRes, yRes: real;

   function GetResolution: real;
     var
       resolution: array[1..2] of LongInt;
   begin
       SaveFPos := FilePos(tiff);
       Seek(tiff, 0); Seek(tiff, value);
       ByteCount := 8;
       Blockread(tiff, Resolution, Bytecount);
       Seek(tiff, 0); Seek(tiff, SaveFPos);
       if not(IntelByteOrder) then begin
         Swap4Bytes(Resolution[1]);
	 Swap4Bytes(Resolution[2]);
       end;
       if resolution[2] <> 0 then
         GetResolution := resolution[1] / resolution[2]
	   else
	 GetResolution := 0.0;
   end;

 begin
   xRes := 0.0;
   Seek(tiff, 0); Seek(tiff, DirOffset);
   ByteCount := 2;
   BlockRead(tiff, nEntries, ByteCount);
   if ioresult <> 0 then begin
     OpenTiffDirectory := false;
     exit;
   end;
   if not(IntelByteOrder) then Swap2Bytes(nEntries);
   writeln('nEntries : ',nEntries);
   with TiffInfo do begin

     width := 0;
     height := 0;
     BitsPerPixel := 1;
     SamplesPerPixel:=1;
     PlanarConfig := 1;
     OffsetToData := 0;
     Resolution := 0.0;
     ResUnits := tNoUnits;
     OffsetToColorMap := 0;
     OffsetToImageHeader := -1;
     StripOffsetsArray[1] := 0;

   for entry := 1 to nEntries do begin

     GetTiffEntry(tiff, tag, N, value);

     if tag = 0 then begin
       writeln('Invalid TIFF format.');
       OpenTiffDirectory := false;
       exit;
     end;

     case tag of
       ImageWidth: begin
                width := value;
                writeln('Width : ',width);
       end;
       ImageLength: begin
		height := value;
                writeln('Height : ',height);
       end;
       BitsPerSample:  begin
		if N = 1 then begin

	          BitsPerPixel := value;
		  if value = 1 then begin
		    Writeln('TeraVue cannot process 1-bit TIFF files.');
		    OpenTiffDirectory := false;
		    exit;
		  end;
		  if (value = 16) and not importing then begin
		    Writeln('TeraVue cannot process 16-bit TIFF files.');
		    OpenTiffDirectory := false;
		    exit;
		  end;
                  writeln('BitsPerPixel : ',BitsperPixel);
                  FormatType[1] := BitsPerPixel;

		end else begin

		  if N > canmax_h then begin
		    Writeln('TeraVue cannot process as many bands.');
		    OpenTiffDirectory := false;
		    exit;
		  end;
		  SaveFPos := FilePos(tiff);
		  Seek(tiff, 0); Seek(tiff, value);

                  for i := 1 to N do begin
		    ByteCount := 2;
		    Blockread(tiff, ier, ByteCount);
                    Swap2Bytes(ier);
		    if ier = 1 then begin
		      Writeln('TeraVue cannot process 1-bit TIFF files.');
		      OpenTiffDirectory := false;
		      exit;
		    end;
		    if (ier = 16) and not importing then begin
		      Writeln('TeraVue cannot process 16-bit TIFF files.');
		      OpenTiffDirectory := false;
		      exit;
		    end;
                    writeln(i:3,' BitsPerPixel : ',ier);
                    FormatType[i] := BitsPerPixel;
                  end;

		  Seek(tiff, 0); Seek(tiff, SaveFPos);

		end;
       end;
       SamplesPerPixelTag: begin
		  SamplesPerPixel:=value;
(*
		  PutError('NIH Image can only open TIFF files with 1 or 3 samples per pixel.');
		  OpenTiffDirectory := false;
		  exit(OpenTiffDirectory)
*)
                writeln('SamplesPerPixel : ',SamplesPerPixel);
       end;
       PlanarConfigTag:
		if value <> 1 then begin
		  Writeln('TeraVue cannot open RGB files with separate planes.');
		  OpenTiffDirectory := false;
		  exit;
                writeln('PlanarConfigTag : ',value);
		end;
       Compression: begin
		if value <> 1 then begin
		  Writeln('TeraVue cannot open compressed TIFF files.');
		  OpenTiffDirectory := false;
		  exit;
		end;
                writeln('Compression mode : ',value);
       end;
       PhotoInterp: begin
		ZeroIsBlack := value = 1;
                writeln(' : ',value);
       end;
       StripOffsets:
		if N = 1 then
		  OffsetToData := value
		else begin
		  SaveFPos := FilePos(tiff);
		  Seek(tiff, 0); Seek(tiff, value);
		  ByteCount := 8;
		  Blockread(tiff, StripOffsetsArray, ByteCount);
		  Seek(tiff, 0); Seek(tiff, SaveFPos);
		  if not(IntelByteOrder) then begin
		    Swap4Bytes(StripOffsetsArray[1]);
		    Swap4Bytes(StripOffsetsArray[2]);
		  end;
		  writeln('StripOffSetArray : ',StripOffsetsArray[1],' ',StripOffsetsArray[2]);
		end;
       StripByteCount: begin
		  writeln('StripByteCount : ',value);
       end;
       RowsPerStrip:
		if (OffsetToData=0) and (value < height) then begin
		  BytesPerStrip := value * width;
		  if BitsPerPixel = 16 then
		    BytesPerStrip := BytesPerStrip * 2
		  else if SamplesPerPixel = 3 then
		    BytesPerStrip := BytesPerStrip * 3;
		  if StripOffsetsArray[1] = 0 then begin
		    Writeln('Invalid TIFF directory.');
		    OpenTiffDirectory := false;
		    exit;
		  end;
		  if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin
		    Writeln('NIH Image cannot open TIFF files with discontiguous strips.');
		    OpenTiffDirectory := false;
		    exit;
		  end;
		  OffsetToData := StripOffsetsArray[1];
                  writeln('BytesPerStrip : ',BytesPerStrip);
                  writeln('OffsetToData : ',OffsetTodata);
       end;
       XResolution: begin
		XRes := GetResolution;
                writeln('Xresolution : ',XRes);
       end;
       YResolution:  begin
		yRes := GetResolution;
                writeln('Yresolution : ',YRes);
		if (xRes = yRes) and (xRes > 0.0) then begin
		  resolution := xRes;
		  ResUnits := tInches;
		end;
       end;
       ResolutionUnit: begin
		case value of
		  NoUnit:
		    ResUnits := tNoUnits;
		  Centimeter:
		    ResUnits := tCentimeters;
		end;
                writeln('ResolutionUnit : ',ord(ResUnits));
       end;
       ColorMapTag:
		if N = 768 then begin
		  OffsetToColorMap := value;
                  writeln('Palette Offset : ',OffsetToColorMap);
                end;
       ImageHdrTag: begin
		OffsetToImageHeader := value;
                writeln('Header Offset : ',OffsetToImageHeader);
       end;

       end;

     end; {for entry := 1 to nEntries}

     ByteCount := 4;
     BlockRead(tiff, NextIFD, ByteCount);
     if width = 0 then begin
       writeln('Error opening TIFF directory');
       OpenTiffDirectory := false;
       exit;
       end;

  end; {with TiffInfo do}

  OpenTiffDirectory := true;
end;

begin

  get_tiff := 1;

  ncol_capt := 0;
  nlig_capt := 0;
  nbs_samples := 0;
  data_offset := 0;
  palette_offset := 0;
  max_offset := 0;
  nbcol_st :=256;

  HasColorMap := false;

{$I-}

  assign(tiff,nomsc);
  reset(tiff,1);
  if ioresult <> 0 then goto 999;

  if not(OpenTiffHeader (tiff,DirOffset)) then goto 999;
  writeln('DirOffset : ',DirOffset);

  if not OpenTiffDirectory(tiff, DirOffset, TiffInfo, true) then begin
    close(tiff);
    goto 999;
  end;

  with TiffInfo do begin
    nbands := SamplesPerPixel;
    Ncol_capt := width;
    Nlig_capt := height;
    data_offset := OffsetToData;
    HasColorMap := OffsetToColorMap > 0;
  end;

  close(tiff);

{$I+}

  get_tiff := 0;

999:end;

end.

